home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / MacGofer 0.22d / MacGofer Sources / machine.c < prev    next >
Encoding:
C/C++ Source or Header  |  1994-03-22  |  36.8 KB  |  1,428 lines  |  [TEXT/MPS ]

  1. /* --------------------------------------------------------------------------
  2.  * machine.c:   Copyright (c) Mark P Jones 1991-1993.   All rights reserved.
  3.  *              See goferite.h for details and conditions of use etc...
  4.  *              Gofer version 2.28 January 1993
  5.  *
  6.  *        Added checks for interrupt key during execution,
  7.  *        plus rotating cursors.    KH (23/3/92)
  8.  *
  9.  * Graph reduction engine, code generation and execution
  10.  * ------------------------------------------------------------------------*/
  11.  
  12. #include "prelude.h"
  13. #include "storage.h"
  14. #include "connect.h"
  15. #include "errors.h"
  16. #include <setjmp.h>
  17.  
  18. #if MPW
  19. #pragma segment Machine
  20. #endif
  21.  
  22. #if MAC
  23. #include <CursorCtl.h>            /* For cursor spinning          */
  24. #endif
  25.  
  26. /*#define DEBUG_CODE*/
  27. Bool   andorOptimise = TRUE;        /* TRUE => optimise uses of &&, || */
  28. Bool   failOnError   = TRUE;        /* TRUE => abort as soon as error  */
  29.                     /*       occurs           */
  30.  
  31. static Cell svGraph;
  32.  
  33. #if DYNAMIC_STORAGE
  34. int num_addrs = NUM_ADDRS;
  35. #endif
  36.  
  37. /* --------------------------------------------------------------------------
  38.  * Data structures for machine memory (program storage):
  39.  * ------------------------------------------------------------------------*/
  40.  
  41. /* This list defines the sequence of all instructions that can be used in
  42.  * the abstract machine code for Gofer.  The Ins() macro is used to
  43.  * ensure that the correct mapping of instructions to labels is used when
  44.  * compiling the GCC_THREADED version.
  45.  */
  46. #define INSTRLIST    Ins(iLOAD),  Ins(iCELL),   Ins(iCHAR),      \
  47.             Ins(iINT),   Ins(iFLOAT),  Ins(iSTRING),  \
  48.             Ins(iMKAP),  Ins(iUPDATE), Ins(iUPDAP),      \
  49.             Ins(iEVAL),  Ins(iRETURN), Ins(iINTGE),   \
  50.             Ins(iINTEQ), Ins(iINTDV),  Ins(iTEST),      \
  51.             Ins(iGOTO),  Ins(iSETSTK), Ins(iALLOC),      \
  52.             Ins(iSLIDE), Ins(iROOT),   Ins(iDICT),      \
  53.             Ins(iFAIL)
  54.   
  55. #define Ins(x) x
  56. typedef enum { INSTRLIST } Instr;
  57. #undef  Ins
  58.  
  59. typedef Int Label;
  60.  
  61. typedef union {
  62.     Int   mint;
  63. #if !BREAK_FLOATS
  64.       Float mfloat;
  65. #endif
  66.     Cell  cell;
  67.     Text  text;
  68.     Addr  addr;
  69.     Instr instr;
  70.     Label lab;
  71. } MemCell;
  72.  
  73. typedef MemCell far *Memory;
  74. static    Memory        memory;
  75. #define intAt(m)    memory[m].mint
  76. #if !BREAK_FLOATS
  77. #define floatAt(m)  memory[m].mfloat
  78. #endif
  79. #define cellAt(m)   memory[m].cell
  80. #define textAt(m)   memory[m].text
  81. #define addrAt(m)   memory[m].addr
  82. #define instrAt(m)  memory[m].instr
  83. #define labAt(m)    memory[m].lab
  84.  
  85. /* --------------------------------------------------------------------------
  86.  * Local function prototypes:
  87.  * ------------------------------------------------------------------------*/
  88.  
  89. static Void  local instrNone    Args((Instr));
  90. static Void  local instrInt    Args((Instr,Int));
  91. static Void  local instrFloat   Args((Instr,FloatPro));
  92. static Void  local instrCell    Args((Instr,Cell));
  93. static Void  local instrText    Args((Instr,Text));
  94. static Void  local instrLab    Args((Instr,Label));
  95. static Void  local instrIntLab    Args((Instr,Int,Label));
  96. static Void  local instrCellLab Args((Instr,Cell,Label));
  97.  
  98. static Void  local asSTART    Args((Void));
  99. static Label local newLabel    Args((Label));
  100. static Void  local asEND    Args((Void));
  101. static Void  local asDICT    Args((Int));
  102. static Void  local asSLIDE    Args((Int));
  103. static Void  local asMKAP    Args((Int));
  104. static Void  local asUPDATE    Args((Int));
  105. static Void  local asGOTO    Args((Label));
  106.  
  107. #ifdef DEBUG_CODE
  108. static Void  local dissassemble Args((Addr,Addr));
  109. static Void  local printCell    Args((Cell));
  110. static Addr  local dissNone    Args((Addr,String));
  111. static Addr  local dissInt    Args((Addr,String));
  112. static Addr  local dissFloat    Args((Addr,String));
  113. static Addr  local dissCell    Args((Addr,String));
  114. static Addr  local dissText    Args((Addr,String));
  115. static Addr  local dissAddr    Args((Addr,String));
  116. static Addr  local dissIntAddr    Args((Addr,String));
  117. static Addr  local dissCellAddr Args((Addr,String));
  118. #endif
  119.  
  120. static Void  local build    Args((Cell,Int));
  121. static Void  local buildGuards    Args((List,Int));
  122. static Int   local buildLoc    Args((List,Int));
  123.  
  124. static Void  local make     Args((Cell,Int,Label,Label));
  125. static Void  local makeCond    Args((Cell,Cell,Cell,Int,Label,Label));
  126. static Void  local testGuard    Args((Pair,Int,Label,Label,Label));
  127. static Void  local testCase    Args((Pair,Int,Label,Label,Label));
  128.  
  129. static Void  local analyseAp    Args((Cell));
  130. static Void  local buildAp    Args((Cell,Int,Label,Bool));
  131.  
  132. static Void  local evalString   Args((Cell));
  133. static Void  local run        Args((Addr,StackPtr));
  134.  
  135.  
  136.  
  137. /* --------------------------------------------------------------------------
  138.  * Assembler: (Low level, instruction code storage)
  139.  * ------------------------------------------------------------------------*/
  140.  
  141. static Addr  startInstr;        /* first instruction after START   */
  142. static Addr  lastInstr;            /* last instr written (for peephole*/
  143.                     /* optimisations etc.)           */
  144. static Addr  noMatch;            /* address of a single FAIL instr  */
  145. static Int   srsp;            /* simulated runtime stack pointer */
  146.  
  147. #if DYNAMIC_STORAGE
  148.        Int  *offsPosn;
  149. #else
  150. static Int   offsPosn[NUM_OFFSETS];    /* mapping from logical to physical*/
  151.                     /* offset positions           */
  152. #endif
  153.  
  154.  
  155.  
  156. /****************************************************************************
  157.  
  158. IMPORTANT:
  159. ----------
  160.  
  161. See also the comments in machdep.c, prims.c, input.c and Mac Notes.
  162.  
  163. The Gofer garbage collector assumes that the stack is aligned to sizeof(Cell).
  164. The Macintosh MPW compiler requires 2 bytes of workspace
  165. to control Floating point conversions, while Cells require 4 bytes.
  166. Since local stack requirements are PRE-ALLOCATED at the beginning of a 
  167. function (indexed from A6 using the MC680x0 LINK instruction), this 
  168. causes some very unpleasant problems.
  169.  
  170. In order to try to get round this problem, I have defined a small
  171. function to perform float conversions.  Although this function's stack is
  172. misaligned compared with other code, it is *non-recursive* and 
  173. therefore harmless.
  174.  
  175. Note that floating values use 10 bytes of stack when passed by value 
  176. (IEEE extended precision as used by the MC68881). This means that float
  177. primitives have to be redefined in prims.c to avoid recursion.  And be
  178. sure when writing interface code which calls the interpreter that all
  179. values on the stack below CStackBase are properly aligned.  I have seen
  180. many crashes because I accidentally used Boolean rather than int.
  181. For similar reasons, BREAK_FLOAT is unlikely to work on the Mac,
  182. unfortunately.
  183.  
  184.     DON'T CHANGE THIS CODE UNLESS YOU *KNOW* WHAT YOU'RE DOING.
  185.  
  186. KH
  187.  
  188.  
  189. ****************************************************************************/
  190.  
  191.  
  192. Float whnfFloat;               /* value of FLOATCELL (in whnf)     */
  193.  
  194. #if MPW
  195.  
  196. static Void local assignFloat(n)
  197. Cell n;
  198. {
  199.   whnfFloat = floatOf(n);
  200. }
  201.  
  202. static Void local asmFloat(e)
  203. Cell e;
  204. {
  205.    instrFloat(iFLOAT,floatOf(e));
  206.    srsp++;
  207. }
  208. #else
  209.  
  210. #define assignFloat(n)    whnfFloat = floatOf(n)
  211. #define asmFloat(e)    asFLOAT(floatOf(e))
  212. #endif
  213.  
  214.  
  215. static Void local instrNone(opc)    /* Opcode with no operands       */
  216. Instr opc; {
  217.     lastInstr           = getMem(1);
  218.     instrAt(lastInstr) = opc;
  219. }
  220.  
  221. static Void local instrInt(opc,n)    /* Opcode with integer operand       */
  222. Instr opc;
  223. Int   n; {
  224.     lastInstr           = getMem(2);
  225.     instrAt(lastInstr) = opc;
  226.     intAt(lastInstr+1) = n;
  227. }
  228.  
  229. static Void local instrFloat(opc,fl)    /* Opcode with Float operand       */
  230. Instr    opc;
  231. FloatPro fl; {
  232. #if BREAK_FLOATS
  233.     lastInstr         = getMem(3);
  234.     instrAt(lastInstr)     = opc;
  235.     cellAt(lastInstr+1)     = part1Float(fl);
  236.     cellAt(lastInstr+2)  = part2Float(fl);
  237. #else
  238.     lastInstr            = getMem(2);
  239.     instrAt(lastInstr)   = opc;
  240.     floatAt(lastInstr+1) = fl;
  241. #endif
  242. }
  243.  
  244. static Void local instrCell(opc,c)    /* Opcode with Cell operand       */
  245. Instr opc;
  246. Cell  c; {
  247.     lastInstr        = getMem(2);
  248.     instrAt(lastInstr)    = opc;
  249.     cellAt(lastInstr+1) = c;
  250. }
  251.  
  252. static Void local instrText(opc,t)    /* Opcode with Text operand       */
  253. Instr opc;
  254. Text  t; {
  255.     lastInstr        = getMem(2);
  256.     instrAt(lastInstr)    = opc;
  257.     textAt(lastInstr+1) = t;
  258. }
  259.  
  260. static Void local instrLab(opc,l)    /* Opcode with label operand       */
  261. Instr opc;
  262. Label l; {
  263.     lastInstr           = getMem(2);
  264.     instrAt(lastInstr) = opc;
  265.     labAt(lastInstr+1) = l;
  266.     if (l<0)
  267.     internal("bad Label");
  268. }
  269.  
  270. static Void local instrIntLab(opc,n,l)    /* Opcode with int, label operands */
  271. Instr opc;
  272. Int   n;
  273. Label l; {
  274.     lastInstr           = getMem(3);
  275.     instrAt(lastInstr) = opc;
  276.     intAt(lastInstr+1) = n;
  277.     labAt(lastInstr+2) = l;
  278.     if (l<0)
  279.     internal("bad Label");
  280. }
  281.  
  282. static Void local instrCellLab(opc,c,l)    /* Opcode with cell, label operands*/
  283. Instr opc;
  284. Cell  c;
  285. Label l; {
  286.     lastInstr        = getMem(3);
  287.     instrAt(lastInstr)    = opc;
  288.     cellAt(lastInstr+1) = c;
  289.     labAt(lastInstr+2)    = l;
  290.     if (l<0)
  291.     internal("bad Label");
  292. }
  293.  
  294. /* --------------------------------------------------------------------------
  295.  * Main low level assembler control: (includes label assignment and fixup)
  296.  *
  297.  * Labels are used as a simple form of continuation during the code gen:
  298.  *  RUNON    => produce code which does not make jump at end of construction
  299.  *  UPDRET   => produce code which performs UPDATE 0, RETURN at end
  300.  *  VALRET   => produce code which performs RETURN at end
  301.  *  other(d) => produce code which branches to label d at end
  302.  * ------------------------------------------------------------------------*/
  303.  
  304. static    Label          nextLab;           /* next label number to allocate    */
  305. #define SHOULDNTFAIL  (-1)
  306. #define RUNON          (-2)
  307. #define UPDRET          (-3)
  308. #define VALRET          (-4)
  309. #if DYNAMIC_STORAGE
  310.     Addr          *fixups;
  311. #else
  312. static    Addr          fixups[NUM_FIXUPS]; /* fixup table maps Label -> Addr*/
  313. #endif
  314. #define atLabel(n)    fixups[n] = getMem(0)
  315. #define endLabel(d,l) if (d==RUNON) atLabel(l)
  316. #define fix(a)          addrAt(a) = fixups[labAt(a)]
  317.  
  318. static Void local asSTART() {           /* initialise assembler           */
  319.     fixups[0]    = noMatch;
  320.     nextLab    = 1;
  321.     startInstr    = getMem(0);
  322.     lastInstr    = startInstr-1;
  323.     srsp    = 0;
  324.     offsPosn[0] = 0;
  325. }
  326.  
  327. static Label local newLabel(d)           /* allocate new label           */
  328. Label d; {
  329.     if (d==RUNON) {
  330.     if (nextLab>=num_fixups) {
  331.         ERROR(0) "Compiled code too complex (need more than %d fixups)",
  332.         num_fixups
  333.         EEND;
  334.     }
  335.     return nextLab++;
  336.     }
  337.     return d;
  338. }
  339.  
  340. static Void local asEND() {           /* Fix addresses in assembled code  */
  341.     Addr pc = startInstr;
  342.  
  343.     while (pc<=lastInstr)
  344.     switch (instrAt(pc)) {
  345.         case iEVAL     :           /* opcodes taking no arguments       */
  346.         case iFAIL     :
  347.         case iRETURN : pc++;
  348.                break;
  349.  
  350.         case iGOTO     : fix(pc+1);  /* opcodes taking one argument       */
  351.         case iSETSTK :
  352.         case iALLOC  :
  353.         case iSLIDE  :
  354.         case iROOT     :
  355.             case iDICT   :
  356.         case iLOAD     :
  357.         case iCELL     :
  358.         case iCHAR     :
  359.         case iINT     :
  360. #if !BREAK_FLOATS
  361.         case iFLOAT  :
  362.  #endif
  363.         case iSTRING :
  364.         case iMKAP     :
  365.         case iUPDATE :
  366.         case iUPDAP  : pc+=2;
  367.                break;
  368. #if BREAK_FLOATS
  369.         case iFLOAT  : pc+=3;
  370.                break;
  371. #endif
  372.  
  373.         case iINTGE  :           /* opcodes taking two arguments       */
  374.         case iINTEQ  :
  375.         case iINTDV     :
  376.         case iTEST     : fix(pc+2);
  377.                pc+=3;
  378.                break;
  379.  
  380.         default     : internal("fixAddrs");
  381.     }
  382. }
  383.  
  384. /* --------------------------------------------------------------------------
  385.  * Assembler Opcodes: (includes simple peephole optimisations)
  386.  * ------------------------------------------------------------------------*/
  387.  
  388. #define asINTEGER(n) instrInt(iINT,n);        srsp++
  389. #define asFLOAT(fl)  instrFloat(iFLOAT,fl);    srsp++
  390. #define asSTRING(t)  instrText(iSTRING,t);    srsp++
  391. #define asCHAR(n)    instrInt(iCHAR,n);        srsp++
  392. #define asLOAD(n)    instrInt(iLOAD,n);        srsp++
  393. #define asALLOC(n)   instrInt(iALLOC,n);    srsp+=n
  394. #define asROOT(n)    instrInt(iROOT,n);        srsp++
  395. #define asSETSTK(n)  instrInt(iSETSTK,n);    srsp=n
  396. #define asEVAL()     instrNone(iEVAL);        srsp--    /* inaccurate srsp */
  397. #define asRETURN()   instrNone(iRETURN)
  398. #define asCELL(c)    instrCell(iCELL,c);    srsp++
  399. #define asTEST(c,l)  instrCellLab(iTEST,c,l)        /* inaccurate srsp */
  400. #define asINTGE(n,l) instrIntLab(iINTGE,n,l)        /* inaccurate srsp */
  401. #define asINTEQ(n,l) instrIntLab(iINTEQ,n,l)
  402. #define asINTDV(n,l) instrIntLab(iINTDV,n,l)        /* inaccurate srsp */
  403. #define asFAIL()     instrNone(iFAIL)
  404.  
  405. static Void local asDICT(n)        /* pick element of dictionary       */
  406. Int n; {
  407. /* Sadly, the following optimisation cannot be used unless CELL references
  408.  * in compiled code are garbage collected (and possibly modified when cell  
  409.  * indirections are found).
  410.  *
  411.  *    if (instrAt(lastInstr)==iCELL)
  412.  *    -- Peephole optimisation: CELL {dict m};DICT n ==> CELL dict(m+n)
  413.  *    if (whatIs(cellAt(lastInstr+1))==DICTCELL)
  414.  *        cellAt(lastInstr+1) = dict(dictOf(cellAt(lastInstr+1))+n);
  415.  *    else
  416.  *        internal("asDICT");
  417.  *    else  ...
  418.  */
  419.     if (n!=0)                /* optimisation:DICT 0 has no use  */
  420.     instrInt(iDICT,n);        /* for std dictionary construction */
  421. }
  422.  
  423. static Void local asSLIDE(n)        /* Slide results down stack       */
  424. Int n; {
  425.     if (instrAt(lastInstr)==iSLIDE)    /* Peephole optimisation:       */
  426.     intAt(lastInstr+1)+=n;        /* SLIDE n;SLIDE m ===> SLIDE (n+m)*/
  427.     else
  428.     instrInt(iSLIDE,n);
  429.     srsp -= n;
  430. }
  431.  
  432. static Void local asMKAP(n)        /* Make application nodes ...       */
  433. Int n; {
  434.     if (instrAt(lastInstr)==iMKAP)    /* Peephole optimisation:       */
  435.     intAt(lastInstr+1)+=n;        /* MKAP n; MKAP m  ===> MKAP (n+m) */
  436.     else
  437.     instrInt(iMKAP,n);
  438.     srsp -= n;
  439. }
  440.  
  441. static Void local asUPDATE(n)        /* Update node ...           */
  442. Int n; {
  443.     if (instrAt(lastInstr)==iMKAP) {    /* Peephole optimisations:       */
  444.     if (intAt(lastInstr+1)>1) {    /* MKAP (n+1); UPDATE p           */
  445.         intAt(lastInstr+1)--;    /*          ===> MKAP n; UPDAP p */
  446.         instrInt(iUPDAP,n);
  447.     }
  448.     else {
  449.         instrAt(lastInstr) = iUPDAP;
  450.         intAt(lastInstr+1) = n;    /* MKAP 1; UPDATE p ===> UPDAP p   */
  451.     }
  452.     }
  453.     else
  454.     instrInt(iUPDATE,n);
  455.     srsp--;
  456. }
  457.  
  458. static Void local asGOTO(l)        /* End evaluation of expr in manner*/
  459. Label l; {                /* indicated by label l           */
  460.     switch (l) {                    /* inaccurate srsp */
  461.     case UPDRET : asUPDATE(0);
  462.     case VALRET : asRETURN();
  463.     case RUNON  : break;
  464.     default     : instrLab(iGOTO,l);
  465.               break;
  466.     }
  467. }
  468.  
  469. /* --------------------------------------------------------------------------
  470.  * Dissassembler:
  471.  * ------------------------------------------------------------------------*/
  472.  
  473. #ifdef DEBUG_CODE
  474. #define printAddr(a) printf("0x%04X",a)/* printable representation of Addr */
  475.  
  476. static Void local dissassemble(pc,end) /* print dissassembly of code       */
  477. Addr pc;
  478. Addr end; {
  479.     while (pc<=end) {
  480.     printAddr(pc);
  481.     printf("\t");
  482.     switch (instrAt(pc)) {
  483.         case iLOAD     : pc = dissInt(pc,"LOAD");     break;
  484.         case iCELL     : pc = dissCell(pc,"CELL");     break;
  485.         case iCHAR     : pc = dissInt(pc,"CHAR");     break;
  486.         case iINT     : pc = dissInt(pc,"INT");     break;
  487.         case iFLOAT  : pc = dissFloat(pc,"FLOAT");   break;
  488.         case iSTRING : pc = dissText(pc,"STRING");     break;
  489.         case iMKAP     : pc = dissInt(pc,"MKAP");     break;
  490.         case iUPDATE : pc = dissInt(pc,"UPDATE");     break;
  491.         case iUPDAP  : pc = dissInt(pc,"UPDAP");     break;
  492.         case iEVAL     : pc = dissNone(pc,"EVAL");     break;
  493.         case iRETURN : pc = dissNone(pc,"RETURN");     break;
  494.         case iINTGE  : pc = dissIntAddr(pc,"INTGE"); break;
  495.         case iINTEQ  : pc = dissIntAddr(pc,"INTEQ"); break;
  496.         case iINTDV  : pc = dissIntAddr(pc,"INTDV"); break;
  497.         case iTEST     : pc = dissCellAddr(pc,"TEST"); break;
  498.         case iGOTO     : pc = dissAddr(pc,"GOTO");     break;
  499.         case iSETSTK : pc = dissInt(pc,"SETSTK");     break;
  500.         case iALLOC  : pc = dissInt(pc,"ALLOC");     break;
  501.         case iSLIDE  : pc = dissInt(pc,"SLIDE");     break;
  502.         case iROOT     : pc = dissInt(pc,"ROOT");     break;
  503.             case iDICT   : pc = dissInt(pc,"DICT");      break;
  504.         case iFAIL     : pc = dissNone(pc,"FAIL");     break;
  505.         default     : internal("unknown instruction");
  506.     }
  507.     }
  508. }
  509.  
  510. static Void local printCell(c)           /* printable representation of Cell */
  511. Cell c; {
  512.     if (isName(c))
  513.     printf("%s",textToStr(name(c).text));
  514.     else
  515.     printf("$%d",c);
  516. }
  517.  
  518. static Addr local dissNone(pc,s)       /* dissassemble instr no args       */
  519. Addr   pc;
  520. String s; {
  521.     printf("%s\n",s);
  522.     return pc+1;
  523. }
  524.  
  525. static Addr local dissInt(pc,s)        /* dissassemble instr with Int arg  */
  526. Addr   pc;
  527. String s; {
  528.     printf("%s\t%d\n",s,intAt(pc+1));
  529.     return pc+2;
  530. }
  531.  
  532. static Addr local dissFloat(pc,s)      /* dissassemble instr with Float arg*/
  533. Addr   pc;
  534. String s; {
  535. #if BREAK_FLOATS
  536.     printf("%s\t%s\n",s,
  537.     floatToString(floatFromParts(cellAt(pc+1),cellAt(pc+2))));
  538.     return pc+3;
  539. #else
  540.     printf("%s\t%s\n",s,floatToString((FloatPro)floatAt(pc+1)));
  541.     return pc+2;
  542. #endif
  543. }
  544.  
  545. static Addr local dissCell(pc,s)       /* dissassemble instr with Cell arg */
  546. Addr   pc;
  547. String s; {
  548.     printf("%s\t",s);
  549.     printCell(cellAt(pc+1));
  550.     printf("\n");
  551.     return pc+2;
  552. }
  553.  
  554. static Addr local dissText(pc,s)       /* dissassemble instr with Text arg */
  555. Addr   pc;
  556. String s; {
  557.     printf("%s\t%s\n",s,textToStr(textAt(pc+1)));
  558.     return pc+2;
  559. }
  560.  
  561. static Addr local dissAddr(pc,s)       /* dissassemble instr with Addr arg */
  562. Addr   pc;
  563. String s; {
  564.     printf("%s\t",s);
  565.     printAddr(addrAt(pc+1));
  566.     printf("\n");
  567.     return pc+2;
  568. }
  569.  
  570. static Addr local dissIntAddr(pc,s)    /* dissassemble instr with Int/Addr */
  571. Addr   pc;
  572. String s; {
  573.     printf("%s\t%d\t",s,intAt(pc+1));
  574.     printAddr(addrAt(pc+2));
  575.     printf("\n");
  576.     return pc+3;
  577. }
  578.  
  579. static Addr local dissCellAddr(pc,s)   /* dissassemble instr with Cell/Addr*/
  580. Addr   pc;
  581. String s; {
  582.     printf("%s\t",s);
  583.     printCell(cellAt(pc+1));
  584.     printf("\t");
  585.     printAddr(addrAt(pc+2));
  586.     printf("\n");
  587.     return pc+3;
  588. }
  589. #endif
  590.  
  591. /* --------------------------------------------------------------------------
  592.  * Compile expression to code which will build expression without any
  593.  * evaluation.
  594.  * ------------------------------------------------------------------------*/
  595.  
  596. static Void local build(e,co)        /* Generate code which will build  */
  597. Cell e;                    /* instance of given expression but*/
  598. Int  co; {                /* perform no evaluation        */
  599.     Int n;
  600.  
  601.     STACK_CHECK;
  602.  
  603.     switch (whatIs(e)) {
  604.  
  605.     case LETREC    : n = buildLoc(fst(snd(e)),co);
  606.                  build(snd(snd(e)),co+n);
  607.                  asSLIDE(n);
  608.                  break;
  609.  
  610.     case FATBAR    : build(snd(snd(e)),co);
  611.                  build(fst(snd(e)),co);
  612.                  asCELL(nameFatbar);
  613.                  asMKAP(2);
  614.                  break;
  615.  
  616.     case COND      : build(thd3(snd(e)),co);
  617.                  build(snd3(snd(e)),co);
  618.                  build(fst3(snd(e)),co);
  619.                  asCELL(nameIf);
  620.                    asMKAP(3);
  621.                    break;
  622.  
  623.     case GUARDED   : buildGuards(snd(e),co);
  624.                  break;
  625.  
  626.     case AP        : buildAp(e,co,SHOULDNTFAIL,FALSE);
  627.                  break;
  628.  
  629.     case UNIT      :
  630.     case TUPLE     :
  631.     case NAME      : asCELL(e);
  632.              break;
  633.  
  634.     case DICTCELL  : asCELL(dict(dictOf(e)));    /* see comments for*/
  635.              break;                /* DICTCELL in make*/
  636.                             /* function below  */
  637.     case INTCELL   : asINTEGER(intOf(e));
  638.              break;
  639.  
  640.         case FLOATCELL : asmFloat(e);
  641.              break;
  642.  
  643.     case STRCELL   : asSTRING(textOf(e));
  644.              break;
  645.  
  646.     case CHARCELL  : asCHAR(charOf(e));
  647.              break;
  648.  
  649.     case OFFSET    : asLOAD(offsPosn[offsetOf(e)]);
  650.                  break;
  651.  
  652.     default        : internal("build");
  653.     }
  654. }
  655.  
  656. static Void local buildGuards(gs,co)    /* Generate code to compile list   */
  657. List gs;                /* of guards to a conditional expr */
  658. Int  co; {                /* without evaluation           */
  659.     if (isNull(gs)) {
  660.     asCELL(nameFail);
  661.     }
  662.     else {
  663.     buildGuards(tl(gs),co);
  664.     build(snd(hd(gs)),co);
  665.     build(fst(hd(gs)),co);
  666.     asCELL(nameIf);
  667.     asMKAP(3);
  668.     }
  669. }
  670.  
  671. static Int local buildLoc(vs,co)    /* Generate code to build local var*/
  672. List vs;                /* bindings on stack,  with no eval*/
  673. Int  co; {
  674.     Int n = length(vs);
  675.     Int i;
  676.  
  677.     for (i=1; i<=n; i++)
  678.     offsPosn[co+i] = srsp+i;
  679.     asALLOC(n);
  680.     for (i=1; i<=n; i++) {
  681.     build(hd(vs),co+n);
  682.     asUPDATE(offsPosn[co+i]);
  683.     vs = tl(vs);
  684.     }
  685.     return n;
  686. }
  687.  
  688. /* --------------------------------------------------------------------------
  689.  * Compile expression to code which will build expression evaluating guards
  690.  * and testing cases to avoid building complete graph.
  691.  * ------------------------------------------------------------------------*/
  692.  
  693. #define makeTests(ct,tests,co,f,d)     {   Label l1 = newLabel(d);        \
  694.                        List  xs = tests;            \
  695.                        while (nonNull(tl(xs))) {        \
  696.                            Label l2   = newLabel(RUNON);\
  697.                            Int savesp = srsp;        \
  698.                            ct(hd(xs),co,f,l2,l1);        \
  699.                            atLabel(l2);            \
  700.                            srsp = savesp;            \
  701.                            xs   = tl(xs);            \
  702.                        }                    \
  703.                        ct(hd(xs),co,f,f,d);            \
  704.                        endLabel(d,l1);            \
  705.                        }
  706.  
  707. static Void local make(e,co,f,d)       /* Construct code to build e, given */
  708. Cell  e;                   /* current offset co, and branch       */
  709. Int   co;                   /* to f on failure, d on completion */
  710. Label f;
  711. Label d; {
  712.     STACK_CHECK;
  713.     
  714.     switch (whatIs(e)) {
  715.  
  716.     case LETREC    : {   Int n = buildLoc(fst(snd(e)),co);
  717.                  make(snd(snd(e)),co+n,f,RUNON);
  718.                  asSLIDE(n);
  719.                  asGOTO(d);
  720.                  }
  721.                  break;
  722.  
  723.     case FATBAR    : {   Label l1     = newLabel(RUNON);
  724.                  Label l2     = newLabel(d);
  725.                  Int   savesp = srsp;
  726.  
  727.                  make(fst(snd(e)),co,l1,l2);
  728.  
  729.                  atLabel(l1);
  730.                  srsp = savesp;
  731.                  asSETSTK(srsp);
  732.                  make(snd(snd(e)),co,f,l2);
  733.  
  734.                  endLabel(d,l2);
  735.                  }
  736.                  break;
  737.  
  738.     case COND      : makeCond(fst3(snd(e)),
  739.                   snd3(snd(e)),
  740.                   thd3(snd(e)),co,f,d);
  741.                  break;
  742.  
  743.     case CASE      : make(fst(snd(e)),co,SHOULDNTFAIL,RUNON);
  744.                  asEVAL();
  745.                  makeTests(testCase,snd(snd(e)),co,f,d);
  746.                  break;
  747.  
  748.     case GUARDED   : makeTests(testGuard,snd(e),co,f,d);
  749.                  break;
  750.  
  751.     case AP        : if (andorOptimise) {
  752.                  Cell h = getHead(e);
  753.                  if (h==nameAnd && argCount==2) {
  754.                  /* x && y ==> if x then y else False       */
  755.                  makeCond(arg(fun(e)),arg(e),nameFalse,co,f,d);
  756.                  break;
  757.                  }
  758.                  else if (h==nameOr && argCount==2) {
  759.                  /* x || y ==> if x then True else y       */
  760.                  makeCond(arg(fun(e)),nameTrue,arg(e),co,f,d);
  761.                  break;
  762.                  }
  763.              }
  764.                          buildAp(e,co,f,TRUE);
  765.                          asGOTO(d);
  766.                          break;
  767.  
  768.     case UNIT      :
  769.     case TUPLE     :
  770.     case NAME      : asCELL(e);
  771.                  asGOTO(d);
  772.                  break;
  773.  
  774.     /* for dict cells, ensure that CELL referred to in the code is the */
  775.     /* dictionary cell at the head of the dictionary; not just a copy  */
  776.  
  777.     case DICTCELL  : asCELL(dict(dictOf(e)));
  778.                  asGOTO(d);
  779.                  break;
  780.  
  781.     case INTCELL   : asINTEGER(intOf(e));
  782.                  asGOTO(d);
  783.                  break;
  784.  
  785.         case FLOATCELL : asmFloat(e);
  786.                  asGOTO(d);
  787.              break;
  788.  
  789.     case STRCELL   : asSTRING(textOf(e));
  790.                  asGOTO(d);
  791.                  break;
  792.  
  793.     case CHARCELL  : asCHAR(charOf(e));
  794.                  asGOTO(d);
  795.                  break;
  796.  
  797.     case OFFSET    : asLOAD(offsPosn[offsetOf(e)]);
  798.                  asGOTO(d);
  799.                  break;
  800.  
  801.     default        : internal("make");
  802.     }
  803. }
  804.  
  805. static Void local makeCond(i,t,e,co,f,d)/* Build code for conditional       */
  806. Cell  i,t,e;
  807. Int   co;
  808. Label f;
  809. Label d; {
  810.     Label l1 = newLabel(RUNON);
  811.     Label l2 = newLabel(d);
  812.     Int   savesp;
  813.  
  814.     make(i,co,f,RUNON);
  815.     asEVAL();
  816.  
  817.     savesp = srsp;
  818.     asTEST(nameTrue,l1);
  819.     make(t,co,f,l2);
  820.  
  821.     srsp = savesp;
  822.     atLabel(l1);
  823.     make(e,co,f,l2);
  824.  
  825.     endLabel(d,l2);
  826. }
  827.  
  828. static Void local testGuard(g,co,f,cf,d)/* Produce code for guard       */
  829. Pair  g;
  830. Int   co;
  831. Label f;
  832. Label cf;
  833. Label d; {
  834.     make(fst(g),co,SHOULDNTFAIL,RUNON);
  835.     asEVAL();
  836.     asTEST(nameTrue,cf);
  837.     make(snd(g),co,f,d);
  838. }
  839.  
  840. static Void local testCase(c,co,f,cf,d) /* Produce code for guard       */
  841. Pair  c;
  842. Int   co;                /* labels determine where to go if:*/
  843. Label f;                /* match succeeds, but rest fails  */
  844. Label cf;                /* this match fails           */
  845. Label d; {
  846.     Int n = discrArity(fst(c));
  847.     Int i;
  848.     switch (whatIs(fst(c))) {
  849.     case INTCELL : asINTEQ(intOf(fst(c)),cf);
  850.                break;
  851.     case ADDPAT  : asINTGE(intValOf(fst(c)),cf);
  852.                break;
  853.     case MULPAT  : asINTDV(intValOf(fst(c)),cf);
  854.                break;
  855.     default      : asTEST(fst(c),cf);
  856.                break;
  857.     }
  858.     for (i=1; i<=n; i++)
  859.     offsPosn[co+i] = ++srsp;
  860.     make(snd(c),co+n,f,d);
  861. }
  862.  
  863. /* --------------------------------------------------------------------------
  864.  * We frequently encounter functions which call themselves recursively with
  865.  * a number of initial arguments preserved:
  866.  * e.g.  (map f) []    = []
  867.  *     (map f) (x:xs) = f x : (map f) xs
  868.  * Lambda lifting, in particular, is likely to introduce such functions.
  869.  * Rather than reconstructing a new instance of the recursive function and
  870.  * its arguments, we can extract the relevant portion of the root of the
  871.  * current redex.
  872.  *
  873.  * The following functions implement this optimisation.
  874.  * ------------------------------------------------------------------------*/
  875.  
  876. static Int  nonRoots;               /* #args which can't get from root  */
  877. static Int  rootPortion;           /* portion of root used ...       */
  878. static Name definingName;           /* name of func being defined,if any*/
  879. static Int  definingArity;           /* arity of definingName        */
  880.  
  881. static Void local analyseAp(e)           /* Determine if any portion of an   */
  882. Cell e; {                   /* application can be built using a */
  883.     if (isAp(e)) {               /* portion of the root           */
  884.     analyseAp(fun(e));
  885.     if (nonRoots==0 && rootPortion>1
  886.             && isOffset(arg(e))
  887.             && offsetOf(arg(e))==rootPortion-1)
  888.         rootPortion--;
  889.     else
  890.         nonRoots++;
  891.     }
  892.     else if (e==definingName)
  893.     rootPortion = definingArity+1;
  894.     else
  895.     rootPortion = 0;
  896. }
  897.  
  898. static Void local buildAp(e,co,f,str)    /* Build application, making use of*/
  899. Cell  e;                /* root optimisation if poss.       */
  900. Int   co;
  901. Label f;
  902. Bool  str; {
  903.     Int nr, rp, i;
  904.  
  905.     nonRoots = 0;
  906.     analyseAp(e);
  907.     nr = nonRoots;
  908.     rp = rootPortion;
  909.  
  910.     for (i=0; i<nr; ++i) {
  911.     build(arg(e),co);
  912.     e = fun(e);
  913.     }
  914.  
  915.     if (isSelect(e)) {
  916.         if (selectOf(e)>0) {
  917.         asDICT(selectOf(e));
  918.     }
  919.     }
  920.     else {
  921.     if (isName(e) && name(e).defn==MFUN) {
  922.         asDICT(name(e).number);
  923.         nr--;    /* AP node for member function need never be built */
  924.     }
  925.     else {
  926.         if (0<rp && rp<=definingArity) {
  927.         asROOT(rp-1);
  928.             }
  929.         else
  930.         if (str)
  931.             make(e,co,f,RUNON);
  932.         else
  933.             build(e,co);
  934.     }
  935.  
  936.     if (nr>0) {
  937.         asMKAP(nr);
  938.         }
  939.     }
  940. }
  941.  
  942. /* --------------------------------------------------------------------------
  943.  * Code generator entry point:
  944.  * ------------------------------------------------------------------------*/
  945.  
  946. Addr codeGen(n,arity,e)            /* Generate code for expression e,  */
  947. Name n;                    /* treating return value of CAFs    */
  948. Int  arity;                   /* differently to functs with args  */
  949. Cell e; {
  950.     definingName  = n;
  951.     definingArity = arity;
  952.     asSTART();
  953.     if (nonNull(n)) {
  954.         Int i;
  955.         for (i=1; i<=arity; i++)
  956.         offsPosn[i] = ++srsp;
  957.         make(e,arity,noMatch,(arity>0 ? UPDRET : VALRET));
  958.     }
  959.     else {
  960.         build(e,0);
  961.         asRETURN();
  962.     }
  963.     asEND();
  964. #ifdef DEBUG_CODE
  965.     if (nonNull(n))
  966.     printf("name=%s\n",textToStr(name(n).text));
  967.     dissassemble(startInstr,lastInstr);
  968.     printf("------------------\n");
  969. #endif
  970.     if (nonNull(n))
  971.     name(n).defn  = NIL;
  972.     return startInstr;
  973. }
  974.  
  975. /* --------------------------------------------------------------------------
  976.  * Evaluator:
  977.  * ------------------------------------------------------------------------*/
  978.  
  979. Int   whnfArgs;                   /* number of arguments of whnf term */
  980. Cell  whnfHead;                   /* head cell of term in whnf       */
  981. Int   whnfInt;                   /* value of INTCELL (in whnf)       */
  982. #if 0    /* Now declared above -- KH */
  983. Float whnfFloat;               /* value of FLOATCELL (in whnf)     */
  984. #endif
  985. Long  numReductions;               /* number of reductions counted       */
  986.  
  987. static Cell    errorRedex;           /* irreducible error expression       */
  988. static jmp_buf *evalError = 0;           /* jump buffer for eval errors       */
  989.  
  990. Void eval(n)                   /* Graph reduction evaluator    */
  991. Cell n; {
  992.     StackPtr base = sp;
  993.     Int      ar;
  994.  
  995.     STACK_CHECK;
  996.     
  997. unw:
  998. #if MAC
  999.     /* 
  1000.         Macintosh event-handling.
  1001.  
  1002.     During evaluation, we need to check periodically for interrupts,
  1003.     and also if we're "multitasking" for other events.
  1004.  
  1005.     For simplicity, this is done every EVT_ITERATIONS times we
  1006.     evaluate an expression.  It would be better to set this
  1007.     depending on whether we were multitasking or not -- a shorter
  1008.     interval is better for event handling.  Perhaps it should be
  1009.     a function of a number of ticks, to allow for machines of
  1010.     varying speeds?
  1011.     
  1012.     KH
  1013.     */
  1014.     {
  1015.       extern int USER_ABORT;
  1016.       extern jmp_buf catch_error;
  1017.       extern int MultiTasking, HandlingEvents;
  1018.       extern Boolean quit;
  1019.  
  1020.       /* This is done so we can evaluate in the "background" */
  1021.       static count = 0;
  1022.       if(count++>EVT_ITERATIONS)
  1023.     {
  1024.           /* Just check for interrupts if we're rolling our own events */
  1025.       if(HandlingEvents)
  1026.         CheckInterrupt();
  1027.  
  1028.       else
  1029.         {
  1030.           if(MultiTasking)
  1031.             multitaskeventloop();
  1032.  
  1033.           else
  1034.             {
  1035.               CheckInterrupt();        /* Check for interrupts                   */
  1036.               SpinCursor(4);        /* Rotate the cursor to show we're doing something */
  1037.             }
  1038.  
  1039.           if(quit || USER_ABORT)
  1040.             breakHandler();
  1041.         }
  1042.  
  1043.       count = 0;                /* Reset the iteration count             */
  1044.     }
  1045.     }
  1046. #endif
  1047.  
  1048.     switch (whatIs(n)) {           /* unwind spine of application  */
  1049.  
  1050.     case AP        : push(n);
  1051.              n = fun(n);
  1052.              goto unw;
  1053.  
  1054.     case INDIRECT  : n = arg(n);
  1055.              allowBreak();
  1056.              goto unw;
  1057.  
  1058.     case NAME      : ar = name(n).arity;
  1059.              if (name(n).defn!=CFUN && sp-base>=ar) {
  1060.                  allowBreak();
  1061.                  if (ar>0) {             /* fn with args*/
  1062.                  StackPtr root;
  1063.  
  1064.                  push(NIL);            /* rearrange   */
  1065.                  root = sp;
  1066.                  do {
  1067.                      stack(root) = arg(stack(root-1));
  1068.                      --root;
  1069.                  } while (--ar>0);
  1070.  
  1071.                  if (name(n).primDef)        /* reduce       */
  1072.                      (*name(n).primDef)(root);
  1073.                  else
  1074.                      run(name(n).code,root);
  1075.  
  1076.                  numReductions++;
  1077.                  
  1078.                  if(traceEval) {
  1079.                     printf("===> ");
  1080.                     printExp(stdout,svGraph);
  1081.                     putchar('\n');
  1082.                  }
  1083.  
  1084.                  sp = root;            /* continue... */
  1085.                  n  = pop();
  1086.                  }
  1087.                  else {                /* CAF       */
  1088.                  if (isNull(name(n).defn)) {/* build CAF   */
  1089.                      push(n);            /* save CAF    */
  1090.  
  1091.                      if (name(n).primDef)
  1092.                      (*name(n).primDef)(sp);
  1093.                      else
  1094.                      run(name(n).code,sp);
  1095.  
  1096.                      numReductions++;
  1097.                  
  1098.                      if(traceEval) {
  1099.                            printf("===> ");
  1100.                         printExp(stdout,svGraph);
  1101.                         putchar('\n');
  1102.                      }
  1103.  
  1104.  
  1105.                      name(n).defn = pop();
  1106.                      drop();            /* drop CAF    */
  1107.                  }
  1108.                  n = name(n).defn;        /*already built*/
  1109.                  if (sp>base)
  1110.                      fun(top()) = n;
  1111.                  }
  1112.                  goto unw;
  1113.              }
  1114.              break;
  1115.  
  1116.     case INTCELL   : whnfInt = intOf(n);
  1117.              break;
  1118.  
  1119.         case FLOATCELL : assignFloat(n);
  1120.              break;
  1121.  
  1122.     case STRCELL   : evalString(n);
  1123.              goto unw;
  1124.  
  1125.     case FILECELL  : evalFile(n);
  1126.              goto unw;
  1127.     }
  1128.  
  1129.     whnfHead = n;               /* rearrange components of term on  */
  1130.     whnfArgs = sp - base;           /* stack, now in whnf ...       */
  1131.     for (ar=whnfArgs; ar>0; ar--) {
  1132.     fun(stack(base+ar)) = n;
  1133.     n            = stack(base+ar);
  1134.     stack(base+ar)        = arg(n);
  1135.     }
  1136. }
  1137.  
  1138. Void unwind(n)                   /* unwind spine of application;       */
  1139. Cell n; {                   /* like eval except that we always  */
  1140.     whnfArgs = 0;               /* treat the expression n as if it  */
  1141.                        /* were already in whnf.        */
  1142. unw:switch (whatIs(n)) {
  1143.     case AP        : push(arg(n));
  1144.              whnfArgs++;
  1145.              n = fun(n);
  1146.              goto unw;
  1147.  
  1148.     case INDIRECT  : n = arg(n);
  1149.              allowBreak();
  1150.              goto unw;
  1151.  
  1152.     case INTCELL   : whnfInt = intOf(n);
  1153.              break;
  1154.  
  1155.         case FLOATCELL : assignFloat(n);
  1156.              break;
  1157.  
  1158.     case STRCELL   : evalString(n);
  1159.              goto unw;
  1160.     }
  1161.     whnfHead = n;
  1162. }
  1163.  
  1164. static Void local evalString(n)        /* expand STRCELL at node n       */
  1165. Cell n; {
  1166.     Text t = textOf(n);
  1167.     Int  c = textToStr(t)[0];
  1168.     if (c==0) {
  1169.     fst(n) = INDIRECT;
  1170.     snd(n) = nameNil;
  1171.     return;
  1172.     }
  1173.     else if (c=='\\') {
  1174.     c = textToStr(++t)[0];
  1175.         if (c!='\\')
  1176.         c = 0;
  1177.     }
  1178.     fst(n) = consChar(c);
  1179.     snd(n) = mkStr(++t);
  1180. }
  1181.  
  1182. static Void local run(start,root)      /* execute code beginning at given  */
  1183. Addr     start;                   /* address with local stack starting*/
  1184. StackPtr root; {               /* at given root offset           */
  1185.     register Memory pc = memory+start;
  1186.  
  1187. #if     GCC_THREADED
  1188. #define Ins(x)        &&l##x
  1189. static  void *labs[] = { INSTRLIST };
  1190. #undef  Ins
  1191. #define Case(x)        l##x
  1192. #define    Continue    goto *labs[(pc++)->instr]
  1193. #define    Dispatch    Continue;
  1194. #define EndDispatch
  1195. #else
  1196. #define Dispatch    for (;;) switch((pc++)->instr) {
  1197. #define    Case(x)        case x
  1198. #define    Continue    continue
  1199. #define EndDispatch    default : internal("illegal instruction"); \
  1200.                   break;               \
  1201.             }
  1202. #endif
  1203.  
  1204.     Dispatch
  1205.  
  1206.     Case(iLOAD)   : push(stack(root+pc->mint));     /* load from stack*/
  1207.             pc++;
  1208.             Continue;
  1209.  
  1210.     Case(iCELL)   : push(pc->cell);             /* load const Cell*/
  1211.             pc++;
  1212.             Continue;
  1213.  
  1214.     Case(iCHAR)   : push(mkChar(pc->mint));         /* load char const*/
  1215.             pc++;
  1216.             Continue;
  1217.  
  1218.     Case(iINT)    : push(mkInt(pc->mint));         /* load int const */
  1219.             pc++;
  1220.             Continue;
  1221.  
  1222. #if BREAK_FLOATS
  1223.     Case(iFLOAT)  : push(mkFloat(floatFromParts     /* load dbl const */
  1224.                 (pc->cell,(pc+1)->cell)));
  1225.             pc+=2;
  1226.             Continue;
  1227. #else
  1228.     Case(iFLOAT)  : push(mkFloat(pc->mfloat));     /* load float cnst*/
  1229.             pc++;
  1230.             Continue;
  1231. #endif
  1232.  
  1233.     Case(iSTRING) : push(mkStr(pc->text));         /* load str const */
  1234.             pc++;
  1235.             Continue;
  1236.  
  1237.     Case(iMKAP)   : {   Cell t = pushed(0);         /* make AP nodes  */
  1238.                 Int  i = pc->text;
  1239.                 while (0<i--) {
  1240.                 drop();
  1241.                 t=ap(t,pushed(0));
  1242.                 }
  1243.                 pushed(0)=t;
  1244.             }
  1245.             pc++;
  1246.             Continue;
  1247.  
  1248.     Case(iUPDATE) : {   Cell t = stack(root        /* update cell ...*/
  1249.                          + pc->mint);
  1250.                 fst(t) = INDIRECT;
  1251.                 snd(t) = pop();
  1252.             }
  1253.             pc++;
  1254.             Continue;
  1255.  
  1256.     Case(iUPDAP)  : {   Cell t = stack(root         /* update AP node */
  1257.                          + pc->mint);
  1258.                 fst(t) = pop();
  1259.                 snd(t) = pop();
  1260.             }
  1261.             pc++;
  1262.             Continue;
  1263.  
  1264.     Case(iEVAL)   : eval(pop());             /* evaluate top() */
  1265.             Continue;
  1266.  
  1267.     Case(iRETURN) : return;                 /* terminate       */
  1268.  
  1269.     Case(iINTGE)  : if (whnfInt>=pc->mint) {     /* test integer >=*/
  1270.                 push(mkInt(whnfInt-pc->mint));
  1271.                 pc += 2;
  1272.             }
  1273.             else
  1274.                 pc = memory + (pc+1)->addr;
  1275.             Continue;
  1276.  
  1277.     Case(iINTEQ)  : if (whnfInt==pc->mint)         /* test integer ==*/
  1278.                 pc += 2;
  1279.             else
  1280.                 pc = memory + (pc+1)->addr;
  1281.             Continue;
  1282.  
  1283.     Case(iINTDV)  : if (whnfInt>=0 &&         /* test for mult  */
  1284.                 (whnfInt%(pc->mint)==0)) {
  1285.                 push(mkInt(whnfInt/(pc->mint)));
  1286.                 pc += 2;
  1287.             }
  1288.             else
  1289.                 pc = memory + (pc+1)->addr;
  1290.             Continue;
  1291.  
  1292.     Case(iTEST)   : if (whnfHead==pc->cell)         /* test for cell  */
  1293.                 pc += 2;
  1294.             else
  1295.                 pc = memory + (pc+1)->addr;
  1296.             Continue;
  1297.  
  1298.     Case(iGOTO)   : pc = memory + pc->addr;         /* goto label       */
  1299.             Continue;
  1300.  
  1301.     Case(iSETSTK) : sp=root + pc->mint;          /* set stack ptr  */
  1302.             pc++;
  1303.             Continue;
  1304.  
  1305.     Case(iALLOC)  : {   Int i = pc->mint;         /* alloc loc vars */
  1306.                 chkStack(i);
  1307.                 while (0<i--)
  1308.                 onto(ap(NIL,NIL));
  1309.             }
  1310.             pc++;
  1311.             Continue;
  1312.  
  1313.     Case(iDICT)   : top() = dict(dictOf(top()) + pc->mint);
  1314.             pc++;                 /* dict lookup    */
  1315.             Continue;
  1316.  
  1317.     Case(iROOT)   : {   Cell t = stack(root);     /* partial root   */
  1318.                 Int  i = pc->mint;
  1319.                 while (fst(t)==INDIRECT) {
  1320.                 allowBreak();
  1321.                 t = arg(t);
  1322.                 }
  1323.                 while (0<i--) {
  1324.                 t = fun(t);
  1325.                 while (fst(t)==INDIRECT) {
  1326.                     allowBreak();
  1327.                     t = arg(t);
  1328.                 }
  1329.                 }
  1330.                 push(t);
  1331.             }
  1332.             pc++;
  1333.             Continue;
  1334.  
  1335.     Case(iSLIDE)  : pushed(pc->mint) = top();     /* remove loc vars*/
  1336.             sp -= pc->mint;
  1337.             pc++;
  1338.             Continue;
  1339.  
  1340.     Case(iFAIL)   : evalFails(root);         /* cannot reduce  */
  1341.             return;/*NOT REACHED*/
  1342.  
  1343.     EndDispatch
  1344.  
  1345. #undef Dispatch
  1346. #undef Case
  1347. #undef Continue
  1348. #undef EndDispatch
  1349. }
  1350.  
  1351. Cell evalWithNoError(e)            /* Evaluate expression, returning   */
  1352. Cell e; {                   /* NIL if successful, irreducible   */
  1353.     Cell badRedex;               /* expression if not...           */
  1354.     jmp_buf *oldCatch = evalError;
  1355.  
  1356. #if JMPBUF_ARRAY
  1357.     jmp_buf catch[1];
  1358.     evalError = catch;
  1359.     if (setjmp(catch[0])==0) {
  1360.     eval(e);
  1361.     badRedex = NIL;
  1362.     }
  1363.     else
  1364.     badRedex = errorRedex;
  1365. #else
  1366.     jmp_buf catch;
  1367.     evalError = &catch;
  1368.     if (setjmp(catch)==0) {
  1369.         eval(e); 
  1370.     badRedex = NIL;
  1371.     }
  1372.     else
  1373.         badRedex = errorRedex;
  1374. #endif
  1375.  
  1376.     evalError = oldCatch;
  1377.     return badRedex;
  1378. }
  1379.  
  1380. Void evalFails(root)            /* Eval of current redex fails       */
  1381. StackPtr root; {
  1382.     errorRedex = stack(root);        /* get error & bypass indirections */
  1383.     while (isPair(errorRedex) && fst(errorRedex)==INDIRECT)
  1384.     errorRedex = snd(errorRedex);
  1385.  
  1386.     if (failOnError)
  1387.     abandon("Program",errorRedex);
  1388.     else if (evalError)
  1389.     longjmp(*evalError,1);
  1390.     else
  1391.     internal("uncaught eval error");
  1392. }
  1393.  
  1394. Cell graphForExp() {            /* Build graph for expression to be*/
  1395.     clearStack();            /* reduced...               */
  1396.     run(inputCode,sp);
  1397.     if(traceEval) {
  1398.        svGraph = top();
  1399.        printf(">>>> ");
  1400.        printExp(stdout,svGraph);
  1401.        putchar('\n');
  1402.     }
  1403.     return pop();
  1404. }
  1405.  
  1406. /* --------------------------------------------------------------------------
  1407.  * Machine control:
  1408.  * ------------------------------------------------------------------------*/
  1409.  
  1410. Void machine(what)
  1411. Int what; {
  1412.     switch (what) {
  1413.         case RESET   : svGraph = NIL;
  1414.                    break;
  1415.         case MARK    : mark(svGraph);
  1416.                    break;            
  1417.     case INSTALL : machine(RESET);
  1418.                memory  = (Memory)farCalloc(num_addrs,sizeof(MemCell));
  1419.                if (memory==0)
  1420.                fatal("Cannot allocate program memory");
  1421.                instrNone(iFAIL);
  1422.                noMatch = lastInstr;
  1423.                break;
  1424.     }
  1425. }
  1426.  
  1427. /* ------------------------------------------------------------------------*/
  1428.